home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / tptool.lbr / CHAPTER4.PQS / chapter4.pas
Pascal/Delphi Source File  |  1985-06-03  |  8KB  |  397 lines
  1. {$A-}
  2. PROGRAM CHAPTER4;
  3. {$I TOOLU.PAS}
  4.  
  5. PROCEDURE SORT;
  6. CONST
  7.   MAXCHARS=10000;
  8.   MAXLINES=300;
  9.   MERGEORDER=5;
  10. TYPE
  11.   CHARPOS=1..MAXCHARS;
  12.   CHARBUF=ARRAY[1..MAXCHARS] OF CHARACTER;
  13.   POSBUF=ARRAY[1..MAXLINES] OF CHARPOS;
  14.   POS=0..MAXLINES;
  15.   FDBUF=ARRAY[1..MERGEORDER]OF FILEDESC;
  16. VAR
  17.   LINEBUF:CHARBUF;
  18.   LINEPOS:POSBUF;
  19.   NLINES:POS;
  20.   INFILE:FDBUF;
  21.   OUTFILE:FILEDESC;
  22.   HIGH,LOW,LIM:INTEGER;
  23.   DONE:BOOLEAN;
  24.   NAME:XSTRING;
  25. FUNCTION GTEXT(VAR LINEPOS:POSBUF;VAR NLINES:POS;
  26.   VAR LINEBUF:CHARBUF;INFILE:FILEDESC):BOOLEAN;
  27. VAR
  28.   I,LEN,NEXTPOS:INTEGER;
  29.   TEMP:XSTRING;
  30.   DONE:BOOLEAN;
  31. BEGIN
  32.   NLINES:=0;
  33.   NEXTPOS:=1;
  34.   REPEAT
  35.     DONE:=(GETLINE(TEMP,INFILE,MAXSTR)=FALSE);
  36.     IF(NOT DONE) THEN BEGIN
  37.       NLINES:=NLINES+1;
  38.       LINEPOS[NLINES]:=NEXTPOS;
  39.       LEN:=XLENGTH(TEMP);
  40.       FOR I:=1 TO LEN DO
  41.         LINEBUF[NEXTPOS+I-1]:=TEMP[I];
  42.       LINEBUF[NEXTPOS+LEN]:=ENDSTR;
  43.       NEXTPOS:=NEXTPOS+LEN+1
  44.     END
  45.   UNTIL (DONE) OR (NEXTPOS>= MAXCHARS-MAXSTR)
  46.     OR (NLINES>=MAXLINES);
  47.   GTEXT:=DONE
  48. END;
  49.  
  50. PROCEDURE PTEXT(VAR LINEPOS:POSBUF;NLINES:INTEGER;
  51.   VAR LINEBUF:CHARBUF;OUTFILE:FILEDESC);
  52. VAR
  53.   I,J:INTEGER;
  54. BEGIN
  55.   FOR I:=1 TO NLINES DO BEGIN
  56.       J:=LINEPOS[I];
  57.       WHILE (LINEBUF[J]<>ENDSTR)DO BEGIN
  58.         PUTCF(LINEBUF[J],OUTFILE);
  59.         J:=J+1
  60.       END
  61.     END
  62. END;
  63.  
  64.       
  65.  
  66. PROCEDURE EXCHANGE(VAR LP1,LP2:CHARPOS);
  67. VAR
  68.   TEMP:CHARPOS;
  69. BEGIN
  70.   TEMP:=LP1;
  71.   LP1:=LP2;
  72.   LP2:=TEMP
  73. END;
  74.  
  75. FUNCTION CMP (I,J:CHARPOS;VAR LINEBUF:CHARBUF)
  76.    :INTEGER;
  77. BEGIN
  78.   WHILE(LINEBUF[I]=LINEBUF[J])
  79.    AND (LINEBUF[I]<>ENDSTR) DO BEGIN
  80.      I:=I+1;
  81.      J:=J+1
  82.    END;
  83.    IF(LINEBUF[I]=LINEBUF[J]) THEN
  84.      CMP:=0
  85.    ELSE IF (LINEBUF[I]=ENDSTR) THEN
  86.      CMP:=-1
  87.    ELSE IF (LINEBUF[J]=ENDSTR) THEN
  88.      CMP:=+1
  89.    ELSE IF (LINEBUF[I]<LINEBUF[J]) THEN
  90.      CMP:=-1
  91.    ELSE
  92.      CMP:=+1
  93. END;(*CMP*)
  94.  
  95.  
  96. PROCEDURE QUICK(VAR LINEPOS:POSBUF; NLINE:POS;
  97.   VAR LINEBUF:CHARBUF);
  98. PROCEDURE RQUICK(LO,HI:INTEGER);
  99. VAR
  100.   I,J:INTEGER;
  101.   PIVLINE:CHARPOS;
  102. BEGIN
  103.   IF (LO<HI) THEN BEGIN
  104.     I:=LO;
  105.     J:=HI;
  106.     PIVLINE:=LINEPOS[J];
  107.     REPEAT
  108.       WHILE (I<J)
  109.         AND (CMP(LINEPOS[I],PIVLINE,LINEBUF)<=0) DO
  110.           I:=I+1;
  111.       WHILE  (J>I)
  112.         AND (CMP(LINEPOS[J],PIVLINE,LINEBUF)>=0) DO
  113.           J:=J-1;
  114.       IF(I<J) THEN
  115.       (*OUT OF ORDER PAIR*)
  116.         EXCHANGE(LINEPOS[I],LINEPOS[J])
  117.     UNTIL (I>=J);
  118.     EXCHANGE(LINEPOS[I],LINEPOS[HI]);
  119.     IF(I-LO<HI-I) THEN BEGIN
  120.       RQUICK(LO,I-1);
  121.       RQUICK(I+1,HI)
  122.     END
  123.     ELSE BEGIN
  124.       RQUICK(I+1,HI);
  125.       RQUICK(LO,I-1)
  126.     END
  127.   END
  128. END;(*RQUICK*)
  129.  
  130. BEGIN(*QUICK*)
  131.   RQUICK(1,NLINES)
  132. END;
  133.  
  134.  
  135. PROCEDURE GNAME(N:INTEGER;VAR NAME:XSTRING);
  136. VAR
  137.   JUNK:INTEGER;
  138.   BEGIN
  139.     NAME[1]:=ORD('S');
  140.     NAME[2]:=ORD('T');
  141.     NAME[3]:=ORD('E');
  142.     NAME[4]:=ORD('M');
  143.     NAME[5]:=ORD('P');
  144.     NAME[6]:=ENDSTR;
  145.   JUNK:=ITOC(N,NAME,XLENGTH(NAME)+1)
  146. END;
  147.  
  148. PROCEDURE GOPEN(VAR INFILE:FDBUF;F1,F2:INTEGER);
  149. VAR
  150.   NAME:XSTRING;
  151.   I:1..MERGEORDER;
  152. BEGIN
  153.   FOR I:=1 TO F2-F1+1 DO BEGIN
  154.     GNAME(F1+I-1,NAME);
  155.     INFILE[I]:=MUSTOPEN(NAME,IOREAD)
  156.   END
  157. END;
  158.  
  159. PROCEDURE GREMOVE(VAR INFILE:FDBUF;F1,F2:INTEGER);
  160. VAR
  161.   NAME:XSTRING;
  162.   I:1..MERGEORDER;
  163. BEGIN
  164.   FOR I:= 1 TO F2-F1+1 DO BEGIN
  165.     XCLOSE(INFILE[I]);
  166.     GNAME(F1+I-1,NAME);
  167.     REMOVE(NAME)
  168.   END
  169. END;
  170.  
  171.  
  172. FUNCTION MAKEFILE(N:INTEGER):FILEDESC;
  173. VAR
  174.   NAME:XSTRING;
  175. BEGIN
  176.   GNAME(N,NAME);
  177.  
  178.   MAKEFILE:=MUSTCREATE(NAME,IOWRITE)
  179. END;
  180.  
  181. PROCEDURE MERGE(VAR INFILE:FDBUF; NF:INTEGER;
  182.   OUTFILE:FILEDESC);
  183.  
  184. VAR
  185.   I,J:INTEGER;
  186.   LBP:CHARPOS;
  187.   TEMP:XSTRING;
  188.  
  189. PROCEDURE REHEAP(VAR LINEPOS:POSBUF;NF:POS;
  190.   VAR LINEBUF:CHARBUF);
  191. VAR
  192.   I,J:INTEGER;
  193. BEGIN
  194.   I:=1;
  195.   J:=2*I;
  196.   WHILE(J<=NF)DO BEGIN
  197.     IF(J<NF) THEN
  198.       IF(CMP(LINEPOS[J],LINEPOS[J+1],LINEBUF)>0)THEN
  199.         J:=J+1;
  200.     IF(CMP(LINEPOS[I],LINEPOS[J],LINEBUF)<=0)THEN
  201.       I:=NF
  202.     ELSE
  203.       EXCHANGE(LINEPOS[I],LINEPOS[J]);(*PERCOLATE*)
  204.     I:=J;
  205.     J:=2*I
  206.   END
  207. END;
  208.  
  209. PROCEDURE SCCOPY(VAR S:XSTRING; VAR CB:CHARBUF;
  210.   I:CHARPOS);
  211. VAR J:INTEGER;
  212. BEGIN
  213.   J:=1;
  214.   WHILE(S[J]<>ENDSTR)DO BEGIN
  215.     CB[I]:=S[J];
  216.     J:=J+1;
  217.     I:=I+1
  218.   END;
  219.   CB[I]:=ENDSTR
  220. END;
  221.  
  222. PROCEDURE CSCOPY(VAR CB:CHARBUF;I:CHARPOS;
  223.   VAR S:XSTRING);
  224. VAR J:INTEGER;
  225. BEGIN
  226.   J:=1;
  227.   WHILE(CB[I]<>ENDSTR)DO BEGIN
  228.     S[J]:=CB[I];
  229.     I:=I+1;
  230.     J:=J+1
  231.   END;
  232.   S[J]:=ENDSTR
  233. END;
  234.  
  235. BEGIN(*MERGE*)
  236.   J:=0;
  237.   FOR I:=1 TO NF DO
  238.     IF(GETLINE(TEMP,INFILE[I],MAXSTR)) THEN BEGIN
  239.       LBP:=(I-1)*MAXSTR+1;
  240.       SCCOPY(TEMP,LINEBUF,LBP);
  241.       LINEPOS[I]:=LBP;
  242.       J:=J+1
  243.     END;
  244.   NF:=J;
  245.   QUICK(LINEPOS,NF,LINEBUF);
  246.   WHILE (NF>0) DO BEGIN
  247.     LBP:=LINEPOS[1];
  248.     CSCOPY(LINEBUF,LBP,TEMP);
  249.     PUTSTR(TEMP,OUTFILE);
  250.     I:=LBP DIV MAXSTR +1;
  251.     IF (GETLINE(TEMP,INFILE[I],MAXSTR))THEN
  252.       SCCOPY(TEMP,LINEBUF,LBP)
  253.     ELSE BEGIN
  254.       LINEPOS[1]:=LINEPOS[NF];
  255.       NF:=NF-1
  256.     END;
  257.     REHEAP(LINEPOS,NF,LINEBUF)
  258.   END
  259. END;
  260.  
  261.  
  262. BEGIN
  263.   HIGH:=0;
  264.   REPEAT (*INITIAL FORMTION OF RUNS*)
  265.     DONE:=GTEXT(LINEPOS,NLINES,LINEBUF,STDIN);
  266.     QUICK(LINEPOS,NLINES,LINEBUF);
  267.     HIGH:=HIGH+1;
  268.     OUTFILE:=MAKEFILE(HIGH);
  269.     PTEXT(LINEPOS,NLINES,LINEBUF,OUTFILE);
  270.     XCLOSE(OUTFILE)
  271.   UNTIL (DONE);
  272.   LOW:=1;
  273.   WHILE (LOW<HIGH) DO BEGIN
  274.     LIM:=MIN(LOW+MERGEORDER-1,HIGH);
  275.     GOPEN(INFILE,LOW,LIM);
  276.     HIGH:=HIGH+1;
  277.     OUTFILE:=MAKEFILE(HIGH);
  278.     MERGE(INFILE,LIM-LOW+1,OUTFILE);
  279.     XCLOSE(OUTFILE);
  280.     GREMOVE(INFILE,LOW,LIM);
  281.     LOW:=LOW+MERGEORDER
  282.   END;
  283.   GNAME(HIGH,NAME);
  284.   OUTFILE:=OPEN(NAME,IOREAD);
  285.   FCOPY(OUTFILE,STDOUT);
  286.   XCLOSE(OUTFILE);
  287.   REMOVE(NAME)
  288. END;
  289.  
  290. PROCEDURE UNIQUE;
  291. VAR
  292.   BUF:ARRAY[0..1] OF XSTRING;
  293.   CUR:0..1;
  294. BEGIN
  295.   CUR:=1;
  296.   BUF[1-CUR][1]:=ENDSTR;
  297.   WHILE (GETLINE(BUF[CUR],STDIN,MAXSTR))DO
  298.     IF (NOT EQUAL (BUF[CUR],BUF[1-CUR])) THEN BEGIN
  299.       PUTSTR(BUF[CUR],STDOUT);
  300.       CUR:=1-CUR
  301.     END
  302. END;
  303.  
  304. PROCEDURE KWIC;
  305. CONST
  306.   FOLD=DOLLAR;
  307. VAR
  308.   BUF:XSTRING;
  309.  
  310. PROCEDURE PUTROT(VAR BUF:XSTRING);
  311. VAR I:INTEGER;
  312.  
  313. PROCEDURE ROTATE(VAR BUF:XSTRING;N:INTEGER);
  314. VAR I:INTEGER;
  315. BEGIN
  316.   I:=N;
  317.   WHILE (BUF[I]<>NEWLINE) AND (BUF[I]<>ENDSTR) DO BEGIN
  318.     PUTC(BUF[I]);
  319.     I:=I+1
  320.   END;
  321.   PUTC(FOLD);
  322.   FOR I:=1 TO N-1 DO
  323.     PUTC(BUF[I]);
  324.   PUTC(NEWLINE)
  325. END;(*ROTATE*)
  326.  
  327. BEGIN(*PUTROT*)
  328.   I:=1;
  329.   WHILE(BUF[I]<>NEWLINE) AND (BUF[I]<>ENDSTR) DO BEGIN
  330.     IF (ISALPHANUM(BUF[I])) THEN BEGIN
  331.       ROTATE(BUF,I);(*TOKEN STATRS AT "I"*)
  332.     REPEAT
  333.       I:=I+1
  334.     UNTIL (NOT ISALPHANUM(BUF[I]))
  335.   END;
  336.   I:=I+1
  337.   END
  338.  
  339. END;(*PUTROT*)
  340.  
  341. BEGIN(*KWIC*)
  342.   WHILE(GETLINE(BUF,STDIN,MAXSTR))DO
  343.     PUTROT(BUF)
  344. END;
  345.  
  346. PROCEDURE UNROTATE;
  347. CONST
  348.   MAXOUT=80;
  349.   MIDDLE=40;
  350.   FOLD=DOLLAR;
  351. VAR
  352.   INBUF,OUTBUF:XSTRING;
  353.   I,J,F:INTEGER;
  354. BEGIN
  355.   WHILE(GETLINE(INBUF,STDIN,MAXSTR))DO BEGIN
  356.     FOR I:=1 TO MAXOUT-1 DO
  357.       OUTBUF[I]:=BLANK;
  358.     F:=INDEX(INBUF,FOLD);
  359.     J:=MIDDLE-1;
  360.     FOR I:=XLENGTH(INBUF)-1 DOWNTO F+1 DO BEGIN
  361.       OUTBUF[J]:=INBUF[I];
  362.       J:=J-1;
  363.       IF(J<=0)THEN
  364.         J:=MAXOUT-1
  365.     END;
  366.     J:=MIDDLE+1;
  367.     FOR I:=1 TO F-1 DO BEGIN
  368.       OUTBUF[J]:=INBUF[I];
  369.       J:=J MOD (MAXOUT-1) +1
  370.     END;
  371.     FOR J:=1 TO MAXOUT-1 DO
  372.       IF(OUTBUF[J]<>BLANK) THEN
  373.         I:=J;
  374.     OUTBUF[I+1]:=ENDSTR;
  375.     PUTSTR(OUTBUF,STDOUT);
  376.     PUTC(NEWLINE)
  377.   END
  378. END;
  379.  
  380. PROCEDURE COMMAND;
  381. BEGIN
  382.        IF (GlobalArg1='sort')THEN SORT
  383.   ELSE IF (GlobalArg1='unique')THEN UNIQUE
  384.   ELSE IF (GlobalArg1='kwic')THEN KWIC
  385.   ELSE IF (GlobalArg1='unrotate')THEN UNROTATE
  386.   ELSE IF (GlobalArg1='rotate')THEN WRITELN('ROTATE:NOT SUPPORTED')
  387.   ELSE ERROR('Chap 4: can''t happen');
  388. END;
  389.  
  390.  
  391.  
  392. BEGIN
  393.   COMMAND;
  394.   ENDCMD;
  395. END.
  396.  
  397.